﻿// Copyright (c) Microsoft Corporation.  All Rights Reserved.  See License.txt in the project root for license information.
module FsSrGen
open System
open System.IO

let PrintErr(filename, line, msg) =
    printfn "%s(%d): error : %s" filename line msg
        
let Err(filename, line, msg) =
    PrintErr(filename, line, msg)
    printfn "Note that the syntax of each line is one of these three alternatives:"
    printfn "# comment"
    printfn "ident,\"string\""
    printfn "errNum,ident,\"string\""
    failwith (sprintf "there were errors in the file '%s'" filename)

let xmlBoilerPlateString = @"<?xml version=""1.0"" encoding=""utf-8""?>
<root>
    <!-- 
    Microsoft ResX Schema 
        
    Version 2.0
        
    The primary goals of this format is to allow a simple XML format 
    that is mostly human readable. The generation and parsing of the 
    various data types are done through the TypeConverter classes 
    associated with the data types.
        
    Example:
        
    ... ado.net/XML headers & schema ...
    <resheader name=""resmimetype"">text/microsoft-resx</resheader>
    <resheader name=""version"">2.0</resheader>
    <resheader name=""reader"">System.Resources.ResXResourceReader, System.Windows.Forms, ...</resheader>
    <resheader name=""writer"">System.Resources.ResXResourceWriter, System.Windows.Forms, ...</resheader>
    <data name=""Name1""><value>this is my long string</value><comment>this is a comment</comment></data>
    <data name=""Color1"" type=""System.Drawing.Color, System.Drawing"">Blue</data>
    <data name=""Bitmap1"" mimetype=""application/x-microsoft.net.object.binary.base64"">
        <value>[base64 mime encoded serialized .NET Framework object]</value>
    </data>
    <data name=""Icon1"" type=""System.Drawing.Icon, System.Drawing"" mimetype=""application/x-microsoft.net.object.bytearray.base64"">
        <value>[base64 mime encoded string representing a byte array form of the .NET Framework object]</value>
        <comment>This is a comment</comment>
    </data>
                    
    There are any number of ""resheader"" rows that contain simple 
    name/value pairs.
        
    Each data row contains a name, and value. The row also contains a 
    type or mimetype. Type corresponds to a .NET class that support 
    text/value conversion through the TypeConverter architecture. 
    Classes that don't support this are serialized and stored with the 
    mimetype set.
        
    The mimetype is used for serialized objects, and tells the 
    ResXResourceReader how to depersist the object. This is currently not 
    extensible. For a given mimetype the value must be set accordingly:
        
    Note - application/x-microsoft.net.object.binary.base64 is the format 
    that the ResXResourceWriter will generate, however the reader can 
    read any of the formats listed below.
        
    mimetype: application/x-microsoft.net.object.binary.base64
    value   : The object must be serialized with 
            : System.Runtime.Serialization.Formatters.Binary.BinaryFormatter
            : and then encoded with base64 encoding.
        
    mimetype: application/x-microsoft.net.object.soap.base64
    value   : The object must be serialized with 
            : System.Runtime.Serialization.Formatters.Soap.SoapFormatter
            : and then encoded with base64 encoding.

    mimetype: application/x-microsoft.net.object.bytearray.base64
    value   : The object must be serialized into a byte array 
            : using a System.ComponentModel.TypeConverter
            : and then encoded with base64 encoding.
    -->
    <xsd:schema id=""root"" xmlns="""" xmlns:xsd=""http://www.w3.org/2001/XMLSchema"" xmlns:msdata=""urn:schemas-microsoft-com:xml-msdata"">
    <xsd:import namespace=""http://www.w3.org/XML/1998/namespace"" />
    <xsd:element name=""root"" msdata:IsDataSet=""true"">
        <xsd:complexType>
        <xsd:choice maxOccurs=""unbounded"">
            <xsd:element name=""metadata"">
            <xsd:complexType>
                <xsd:sequence>
                <xsd:element name=""value"" type=""xsd:string"" minOccurs=""0"" />
                </xsd:sequence>
                <xsd:attribute name=""name"" use=""required"" type=""xsd:string"" />
                <xsd:attribute name=""type"" type=""xsd:string"" />
                <xsd:attribute name=""mimetype"" type=""xsd:string"" />
                <xsd:attribute ref=""xml:space"" />
            </xsd:complexType>
            </xsd:element>
            <xsd:element name=""assembly"">
            <xsd:complexType>
                <xsd:attribute name=""alias"" type=""xsd:string"" />
                <xsd:attribute name=""name"" type=""xsd:string"" />
            </xsd:complexType>
            </xsd:element>
            <xsd:element name=""data"">
            <xsd:complexType>
                <xsd:sequence>
                <xsd:element name=""value"" type=""xsd:string"" minOccurs=""0"" msdata:Ordinal=""1"" />
                <xsd:element name=""comment"" type=""xsd:string"" minOccurs=""0"" msdata:Ordinal=""2"" />
                </xsd:sequence>
                <xsd:attribute name=""name"" type=""xsd:string"" use=""required"" msdata:Ordinal=""1"" />
                <xsd:attribute name=""type"" type=""xsd:string"" msdata:Ordinal=""3"" />
                <xsd:attribute name=""mimetype"" type=""xsd:string"" msdata:Ordinal=""4"" />
                <xsd:attribute ref=""xml:space"" />
            </xsd:complexType>
            </xsd:element>
            <xsd:element name=""resheader"">
            <xsd:complexType>
                <xsd:sequence>
                <xsd:element name=""value"" type=""xsd:string"" minOccurs=""0"" msdata:Ordinal=""1"" />
                </xsd:sequence>
                <xsd:attribute name=""name"" type=""xsd:string"" use=""required"" />
            </xsd:complexType>
            </xsd:element>
        </xsd:choice>
        </xsd:complexType>
    </xsd:element>
    </xsd:schema>
    <resheader name=""resmimetype"">
    <value>text/microsoft-resx</value>
    </resheader>
    <resheader name=""version"">
    <value>2.0</value>
    </resheader>
    <resheader name=""reader"">
    <value>System.Resources.ResXResourceReader, System.Windows.Forms, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value>
    </resheader>
    <resheader name=""writer"">
    <value>System.Resources.ResXResourceWriter, System.Windows.Forms, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value>
    </resheader>
</root>"


type HoleType = string


// The kinds of 'holes' we can do
let ComputeHoles filename lineNum (txt:string) : ResizeArray<HoleType> * string =
    // takes in a %d%s kind of string, returns array of HoleType and {0}{1} kind of string
    let mutable i = 0
    let mutable holeNumber = 0
    let mutable holes = ResizeArray()  //  order
    let sb = new System.Text.StringBuilder()
    let AddHole holeType =
        sb.Append(sprintf "{%d}" holeNumber) |> ignore
        holeNumber <- holeNumber + 1
        holes.Add(holeType)
    while i < txt.Length do
        if txt.[i] = '%' then
            if i+1 = txt.Length then
                Err(filename, lineNum, "(at end of string) % must be followed by d, f, s, or %")
            else
                match txt.[i+1] with
                | 'd' -> AddHole "System.Int32"
                | 'f' -> AddHole "System.Double"
                | 's' -> AddHole "System.String"
                | '%' -> sb.Append('%') |> ignore
                | c -> Err(filename, lineNum, sprintf "'%%%c' is not a valid sequence, only %%d %%f %%s or %%%%" c)
            i <- i + 2
        else
            match txt.[i] with
            | '{' -> sb.Append "{{" |> ignore
            | '}' -> sb.Append "}}" |> ignore
            | c -> sb.Append c |> ignore
            i <- i + 1
    //printfn "holes.Length = %d, lineNum = %d" holes.Length //lineNum txt
    (holes, sb.ToString())

let Unquote (s : string) =
    if s.StartsWith "\"" && s.EndsWith "\"" then s.Substring(1, s.Length - 2)
    else failwith "error message string should be quoted"

let ParseLine filename lineNum (txt:string) =
    let mutable errNum = None
    let identB = new System.Text.StringBuilder()
    let mutable i = 0
    // parse optional error number
    if i < txt.Length && System.Char.IsDigit txt.[i] then
        let numB = new System.Text.StringBuilder()
        while i < txt.Length && System.Char.IsDigit txt.[i] do
            numB.Append txt.[i] |> ignore
            i <- i + 1
        errNum <- Some(int (numB.ToString()))
        if i = txt.Length || not(txt.[i] = ',') then
            Err(filename, lineNum, sprintf "After the error number '%d' there should be a comma" errNum.Value)
        // Skip the comma
        i <- i + 1
    // parse short identifier
    if i < txt.Length && not(System.Char.IsLetter(txt.[i])) then
        Err(filename, lineNum, sprintf "The first character in the short identifier should be a letter, but found '%c'" txt.[i])
    while i < txt.Length && System.Char.IsLetterOrDigit txt.[i] do
        identB.Append txt.[i] |> ignore
        i <- i + 1
    let ident = identB.ToString()
    if ident.Length = 0 then
        Err(filename, lineNum, "Did not find the short identifier")
    else
        if i = txt.Length || not(txt.[i] = ',') then
            Err(filename, lineNum, sprintf "After the identifier '%s' there should be a comma" ident)
        else
            // Skip the comma
            i <- i + 1
            if i = txt.Length then
                Err(filename, lineNum, sprintf "After the identifier '%s' and comma, there should be the quoted string resource" ident)
            else
                let str = 
                    try
                        System.String.Format(Unquote(txt.Substring i))  // Format turns e.g '\n' into that char, but also requires that we 'escape' curlies in the original .txt file, e.g. "{{"
                    with 
                        e -> Err(filename, lineNum, sprintf "Error calling System.String.Format (note that curly braces must be escaped, and there cannot be trailing space on the line): >>>%s<<< -- %s" (txt.Substring i) e.Message)
                let holes, netFormatString = ComputeHoles filename lineNum str
                (lineNum, (errNum,ident), str, holes.ToArray(), netFormatString)

let stringBoilerPlatePrefix = @"            
open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators
open Microsoft.FSharp.Reflection
open System.Reflection
// (namespaces below for specific case of using the tool to compile FSharp.Core itself)
open Microsoft.FSharp.Core
open Microsoft.FSharp.Core.Operators
open Microsoft.FSharp.Text
open Microsoft.FSharp.Collections
open Printf
"
let StringBoilerPlate filename =

    @"
    // BEGIN BOILERPLATE        
    
    static let getCurrentAssembly () =
    #if FX_RESHAPED_REFLECTION
        typeof<SR>.GetTypeInfo().Assembly
    #else
        System.Reflection.Assembly.GetExecutingAssembly()
    #endif
        
    static let getTypeInfo (t: System.Type) =
    #if FX_RESHAPED_REFLECTION
        t.GetTypeInfo()
    #else
        t
    #endif
    
    static let resources = lazy (new System.Resources.ResourceManager(""" + filename + @""", getCurrentAssembly()))

    static let GetString(name:string) =        
        let s = resources.Value.GetString(name, System.Globalization.CultureInfo.CurrentUICulture)
    #if DEBUG
        if null = s then
            System.Diagnostics.Debug.Assert(false, sprintf ""**RESOURCE ERROR**: Resource token %s does not exist!"" name)
    #endif
        s

    static let mkFunctionValue (tys: System.Type[]) (impl:obj->obj) = 
        FSharpValue.MakeFunction(FSharpType.MakeFunctionType(tys.[0],tys.[1]), impl)
        
    static let funTyC = typeof<(obj -> obj)>.GetGenericTypeDefinition()  

    static let isNamedType(ty:System.Type) = not (ty.IsArray ||  ty.IsByRef ||  ty.IsPointer)
    static let isFunctionType (ty1:System.Type)  = 
        isNamedType(ty1) && getTypeInfo(ty1).IsGenericType && (ty1.GetGenericTypeDefinition()).Equals(funTyC)

    static let rec destFunTy (ty:System.Type) =
        if isFunctionType ty then 
            ty, ty.GetGenericArguments() 
        else
            match getTypeInfo(ty).BaseType with 
            | null -> failwith ""destFunTy: not a function type"" 
            | b -> destFunTy b 

    static let buildFunctionForOneArgPat (ty: System.Type) impl = 
        let _,tys = destFunTy ty 
        let rty = tys.[1]
        // PERF: this technique is a bit slow (e.g. in simple cases, like 'sprintf ""%x""') 
        mkFunctionValue tys (fun inp -> impl rty inp)
                
    static let capture1 (fmt:string) i args ty (go : obj list -> System.Type -> int -> obj) : obj = 
        match fmt.[i] with
        | '%' -> go args ty (i+1) 
        | 'd'
        | 'f'
        | 's' -> buildFunctionForOneArgPat ty (fun rty n -> go (n::args) rty (i+1))
        | _ -> failwith ""bad format specifier""
        
    // newlines and tabs get converted to strings when read from a resource file
    // this will preserve their original intention    
    static let postProcessString (s : string) =
        s.Replace(""\\n"",""\n"").Replace(""\\t"",""\t"").Replace(""\\r"",""\r"").Replace(""\\\"""", ""\"""")
        
    static let createMessageString (messageString : string) (fmt : Printf.StringFormat<'T>) : 'T = 
        let fmt = fmt.Value // here, we use the actual error string, as opposed to the one stored as fmt
        let len = fmt.Length 

        /// Function to capture the arguments and then run.
        let rec capture args ty i = 
            if i >= len ||  (fmt.[i] = '%' && i+1 >= len) then 
                let b = new System.Text.StringBuilder()    
                b.AppendFormat(messageString, [| for x in List.rev args -> x |]) |> ignore
                box(b.ToString())
            // REVIEW: For these purposes, this should be a nop, but I'm leaving it
            // in incase we ever decide to support labels for the error format string
            // E.g., ""<name>%s<foo>%d""
            elif System.Char.IsSurrogatePair(fmt,i) then 
                capture args ty (i+2)
            else
                match fmt.[i] with
                | '%' ->
                    let i = i+1 
                    capture1 fmt i args ty capture
                | _ ->
                    capture args ty (i+1) 

        (unbox (capture [] (typeof<'T>) 0) : 'T)

    static let mutable swallowResourceText = false
    
    static let GetStringFunc((messageID : string),(fmt : Printf.StringFormat<'T>)) : 'T =
        if swallowResourceText then
            sprintf fmt
        else
            let mutable messageString = GetString(messageID)
            messageString <- postProcessString messageString                            
            createMessageString messageString fmt
        
    /// If set to true, then all error messages will just return the filled 'holes' delimited by ',,,'s - this is for language-neutral testing (e.g. localization-invariant baselines).
    static member SwallowResourceText with get () = swallowResourceText
                                        and set (b) = swallowResourceText <- b
    // END BOILERPLATE        
"            

let RunMain(filename:string, outFilename, outXmlFilenameOpt, projectNameOpt) =
    try
        let justfilename = System.IO.Path.GetFileNameWithoutExtension(filename)
        if justfilename |> Seq.exists (fun c -> not(System.Char.IsLetterOrDigit(c))) then
            Err(filename, 0, sprintf "The filename '%s' is not allowed; only letters and digits can be used, as the filename also becomes the namespace for the SR class" justfilename)

        printfn "fssrgen.fsx: Reading %s" filename 
        let lines = System.IO.File.ReadAllLines(filename) 
                    |> Array.mapi (fun i s -> i,s) // keep line numbers
                    |> Array.filter (fun (i,s) -> not(s.StartsWith "#"))  // filter out comments

        printfn "fssrgen.fsx: Parsing %s" filename 
        let stringInfos = lines |> Array.map (fun (i,s) -> ParseLine filename i s)
        // now we have array of (lineNum, ident, str, holes, netFormatString)  // str has %d, netFormatString has {0}
            
        printfn "fssrgen.fsx: Validating %s" filename 
        // validate that all the idents are unique
        let allIdents = new System.Collections.Generic.Dictionary<string,int>()
        for (line,(_,ident),_,_,_) in stringInfos do
            if allIdents.ContainsKey(ident) then
                Err(filename,line,sprintf "Identifier '%s' is already used previously on line %d - each identifier must be unique" ident allIdents.[ident])
            allIdents.Add(ident,line)
            
        printfn "fssrgen.fsx: Validating uniqueness of %s" filename 
        // validate that all the strings themselves are unique
        let allStrs = new System.Collections.Generic.Dictionary<string,(int*string)>()
        for (line,(_,ident),str,_,_) in stringInfos do
            if allStrs.ContainsKey(str) then
                let prevLine,prevIdent = allStrs.[str]
                Err(filename,line,sprintf "String '%s' already appears on line %d with identifier '%s' - each string must be unique" str prevLine prevIdent)
            allStrs.Add(str,(line,ident))
            
        printfn "fssrgen.fsx: Generating %s" outFilename

        use out = new System.IO.StringWriter()
        fprintfn out "// This is a generated file; the original input is '%s'" filename
        fprintfn out "namespace %s" justfilename
        if Option.isNone outXmlFilenameOpt then
            fprintfn out "type internal SR private() ="
        else
            fprintfn out "%s" stringBoilerPlatePrefix
            fprintfn out "type internal SR private() ="
            let theResourceName = match projectNameOpt with Some p -> sprintf "%s.%s" p justfilename | None -> justfilename
            fprintfn out "%s" (StringBoilerPlate theResourceName)

        printfn "fssrgen.fsx: Generating resource methods for %s" outFilename
        // gen each resource method
        stringInfos |> Seq.iter (fun (lineNum, (optErrNum,ident), str, holes, netFormatString) ->
            let formalArgs = System.Text.StringBuilder()
            let actualArgs = System.Text.StringBuilder()
            let firstTime = ref true
            let n = ref 0
            formalArgs.Append "(" |> ignore
            for hole in holes do
                if !firstTime then
                    firstTime := false
                else
                    formalArgs.Append ", " |> ignore
                    actualArgs.Append " " |> ignore
                formalArgs.Append(sprintf "a%d : %s" !n hole) |> ignore
                actualArgs.Append(sprintf "a%d" !n) |> ignore
                n := !n + 1
            formalArgs.Append ")" |> ignore
            fprintfn out "    /// %s" str
            fprintfn out "    /// (Originally from %s:%d)" filename (lineNum+1)
            let justPercentsFromFormatString = 
                (holes |> Array.fold (fun acc holeType -> 
                    acc + match holeType with 
                            | "System.Int32" -> ",,,%d" 
                            | "System.Double" -> ",,,%f" 
                            | "System.String" -> ",,,%s"
                            | _ -> failwith "unreachable") "") + ",,,"
            let errPrefix = match optErrNum with
                            | None -> ""
                            | Some n -> sprintf "%d, " n
            if Option.isNone outXmlFilenameOpt then
                fprintfn out "    static member %s%s = (%ssprintf \"%s\" %s)" ident (formalArgs.ToString()) errPrefix str (actualArgs.ToString())
            else
                fprintfn out "    static member %s%s = (%sGetStringFunc(\"%s\",\"%s\") %s)" ident (formalArgs.ToString()) errPrefix ident justPercentsFromFormatString (actualArgs.ToString())
            )

        if Option.isSome outXmlFilenameOpt then
            printfn "fssrgen.fsx: Generating .resx for %s" outFilename
            fprintfn out ""
            // gen validation method
            fprintfn out "    /// Call this method once to validate that all known resources are valid; throws if not"
            fprintfn out "    static member RunStartupValidation() ="
            stringInfos |> Seq.iter (fun (lineNum, (optErrNum,ident), str, holes, netFormatString) ->
                fprintfn out "        ignore(GetString(\"%s\"))" ident
            )
            fprintfn out "        ()"  // in case there are 0 strings, we need the generated code to parse

        let outFileNewText = out.ToString()
        let nothingChanged = try File.Exists(outFilename) && File.ReadAllText(outFilename) = outFileNewText with _ -> false
        if not nothingChanged then 
           File.WriteAllText(outFilename, outFileNewText, System.Text.Encoding.UTF8)

        if Option.isSome outXmlFilenameOpt then
            // gen resx
            let xd = new System.Xml.XmlDocument()
            xd.LoadXml(xmlBoilerPlateString)
            stringInfos |> Seq.iter (fun (lineNum, (optErrNum,ident), str, holes, netFormatString) ->
                let xn = xd.CreateElement("data")
                xn.SetAttribute("name",ident) |> ignore
                xn.SetAttribute("xml:space","preserve") |> ignore
                let xnc = xd.CreateElement "value"
                xn.AppendChild xnc |> ignore
                xnc.AppendChild(xd.CreateTextNode netFormatString) |> ignore
                xd.LastChild.AppendChild xn |> ignore
            )
            let outXmlFileNewText = 
                use outXmlStream = new System.IO.StringWriter()
                xd.Save outXmlStream
                outXmlStream.ToString()
            let outXmlFile = outXmlFilenameOpt.Value
            let nothingChanged = try File.Exists(outXmlFile) && File.ReadAllText(outXmlFile) = outXmlFileNewText with _ -> false
            if not nothingChanged then 
               File.WriteAllText(outXmlFile, outXmlFileNewText, System.Text.Encoding.Unicode)


        printfn "fssrgen.fsx: Done %s" outFilename
        0
    with e -> 
        PrintErr(filename, 0, sprintf "An exception occurred when processing '%s'\n%s" filename (e.ToString()))
        1

#if COMPILED
[<EntryPoint>]
#endif
let Main args = 

    match args |> List.ofArray with
    | [ inputFile; outFile; ] ->
        let filename = System.IO.Path.GetFullPath(inputFile)
        let outFilename = System.IO.Path.GetFullPath(outFile)

        RunMain(filename, outFilename, None, None)

    | [ inputFile; outFile; outXml ] ->
        let filename = System.IO.Path.GetFullPath inputFile
        let outFilename = System.IO.Path.GetFullPath outFile
        let outXmlFilename = System.IO.Path.GetFullPath outXml

        RunMain(filename, outFilename, Some outXmlFilename, None)

    | [ inputFile; outFile; outXml; projectName ] ->
        let filename = System.IO.Path.GetFullPath inputFile
        let outFilename = System.IO.Path.GetFullPath outFile
        let outXmlFilename = System.IO.Path.GetFullPath outXml

        RunMain(filename, outFilename, Some outXmlFilename, Some projectName)

    | _ ->
        printfn "Error: invalid arguments."
        printfn "Usage: <INPUTFILE> <OUTPUTFILE> <OUTXMLFILE> <PROJECTNAME>"
        1
#if !COMPILED
printfn "fssrgen: args = %A" fsi.CommandLineArgs
Main (fsi.CommandLineArgs |> Seq.skip 1 |> Seq.toArray)
#endif
